

;
; Common utilities for the minimalistic test suite
;
       
(define-syntax receive
  (syntax-rules ()
    ((receive (arg ...) call body ...)
     (call-with-values 
       (lambda () call)
       (lambda (arg ...) body ...)))))

(define (not x)
  (if x #f #t))

(define (boolean? x)
  (or (eq? x #t)
      (eq? x #f)))

; list operations
;
(define (null? l)
  (eq? l '()))

(define (length/rec l n)
  (if (null? l) n (length/rec (cdr l) (+ n 1))))

(define (length l)
  (length/rec l 0))

(define (list . x) x)

(define (list? l)
  (cond ((eq? l '()) #t)
        ((pair? l)   (list? (cdr l)))
        (else        #f)))

(define (append l1 l2)
  (if (null? l1)
      l2
      (cons (car l1) (append (cdr l1) l2))))

; detect wether this is the real vm, or the vm run in Scheme
;
(define (is-real-vm?)
  (not (string=? (system-parameter (enum system-parameter-option host-architecture)) "s48")))


; showing numbers
;
(define (number->chars-reversed n l)
  (if (= 0 n)
      l
      (cons (vector-ref '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (remainder n 10)) 
            (number->chars-reversed (quotient n 10) l))))

(define (number->string n)
  (if (= n 0) "0"
    ((lambda (l) (reverse-list->string l (length l)))
     (if (> n 0)
       (number->chars-reversed n '())
       (number->chars-reversed (- n) '(#\-))))))

; i/o
;
(define *default-output-port* #f)
(define *default-input-port* #f)  

(define (output-option maybe-port)
  (if (null? maybe-port) *default-output-port* (car maybe-port)))

(define (write-string string . maybe-out)
  (write-string-to-port string (output-option maybe-out)))
  
(define (write-number n . maybe-out)
  (write-string-to-port (number->string n) (output-option maybe-out)))

; writer for simple things
;
(define (write thing . maybe-out)
  (let ((out (output-option maybe-out)))
    (cond
      ((eq? thing #f)
       (write-string-to-port "#f" out))
      ((eq? thing #t)  
       (write-string-to-port "#t" out))
      ((char? thing)
       (write-string-to-port "#\\" out)
       (write-string-to-port (reverse-list->string (list thing) 1) out))
      ((string? thing)
       (write-string-to-port "\"" out) 
       (write-string-to-port thing out)
       (write-string-to-port "\"" out))
      ((number? thing) 
       (write-string-to-port (number->string thing) out))
      ((vector? thing)
       (write-string-to-port "#(" out)
       (let loop ((i 0))
         (if (< i (vector-length thing))
             (write (vector-ref thing i) out))
         (if (< (+ i 1) (vector-length thing))
           (begin             
             (write-string-to-port " " out)
             (loop (+ i 1)))))
       (write-string-to-port ")" out))
      ((null? thing)
       (write-string-to-port "()" out))
      ((list? thing)
       (write-string-to-port "(" out)
       (let loop ((l thing))
         (if (not (null? l))
           (begin
             (write (car l) out)
             (if (not (null? (cdr l)))         
               (begin 
                 (write-string-to-port " " out)
                 (loop (cdr l)))))))
       (write-string-to-port ")" out))
      ((pair? thing)
       (write-string-to-port "(" out)
       (write (car thing) out)
       (write-string-to-port " . " out)
       (write (cdr thing) out)
       (write-string-to-port ")" out))      
      (else            
       (write-string-to-port "{unknown}" out)))))



(define (write-string-to-port string out)
  (write-byte-vector (string->byte-vector string) out))
  

(define (write-byte-vector bytes channel)
  (channel-maybe-write channel
		       bytes
		       0
		       (byte-vector-length bytes)))

(define (string->byte-vector string)
  ((lambda (size)
     ((lambda (bytes)
	(letrec ((loop
		  (lambda (i)
		    (if (< i size)
			(begin
			  (byte-vector-set! bytes i
					    (char->scalar-value (string-ref string i)))
			  (loop (+ 1 i)))))))
	  (loop 0)
	  bytes))
      (make-byte-vector size 0)))
   (string-length string)))

(define (string->low-string string)
  (let* ((size (string-length string))
	 (bytes (make-byte-vector (+ 1 size) 0)))
    (do ((i 0 (+ 1 i)))
	((>= i size))
      (byte-vector-set! bytes i (char->scalar-value (string-ref string i))))
    bytes))
    
(define (low-string->string bytes . maybe-length)
  (let* ((size (if (null? maybe-length)                  
                   (byte-vector-length bytes)
                   (car maybe-length)))
         (string (make-string size #\Space)))
    (do ((i 0 (+ 1 i)))
        ((>= i size))
      (string-set! string i (scalar-value->char (byte-vector-ref bytes i))))
    string))

(define (newline . maybe-channel)
  (apply write-string "
" maybe-channel))

(define (read-string . maybe-in)
  ((lambda (buffer)
     (letrec ((loop (lambda (have)
		      ((lambda (got)
			 (if (eq? got (eof-object))
			     "eof"
			     ((lambda (len)
				(if len
				    ((lambda (string)
				       (copy-bytes-to-string! buffer string len)
				       string)
				     (make-string len #\space))
				    (loop (+ have got))))
			      (has-newline buffer have got))))
		       (channel-maybe-read 
			(if (null? maybe-in)
			    *default-input-port*
			    (car maybe-in))
			buffer have (- 80 have) #f)))))
       (loop 0)))
   (make-byte-vector 80 (char->scalar-value #\space))))

(define (has-newline bytes start count)
  (letrec ((loop (lambda (i)
		   (if (= i count)
		       #f
		       (if (char=? #\newline
				   (scalar-value->char
				    (byte-vector-ref bytes (+ start i))))
			   (+ start i)
			   (loop (+ i 1)))))))
    (loop 0)))

(define (copy-bytes-to-string! from to count)
  (letrec ((loop (lambda (i)
		   (if (< i count)
		       (begin
			 (string-set! to i
				      (scalar-value->char (byte-vector-ref from i)))
			 (loop (+ i 1)))))))
    (loop 0)))


    

